The Programmer Disk/The Programmer Disk (Microforum).iso/xpro/basic1/pro10/glibdemo.bas

BASIC Source File | 1989-04-01 | 29.1 KB | 1,098 lines

DECLARE FUNCTION xMenuChoice% (menu$(), Trow%, LCol%, NAttr%, Hattr%, title$, Mark%(), XtdChc%)
DECLARE FUNCTION xToglMark% (Mark%(), item%, Qmark%, MaxMark%)
' GLIBDEMO version 2
' (C) Copyright 1988
'
' Demo of some of the newer, more useful or more interesting
' routines from GLIB version 1.6.
'
' Written by Gizmo Mike
'
' NOTE: This should have started from the batch file for proper
'       switch settings.
' QB glibdemo /l glib16 /cmd <scrfile> <3 or 4 fake switches>

DECLARE FUNCTION AttrMake% (fg%, bg%)
DECLARE FUNCTION MenuChoice% (menu$(), Trow%, LCol%, NAttr%, Hattr%, title$, Mark%(), XtdChc%)
DECLARE FUNCTION DIR% (mask$, BYVAL FilArryPtr)
DECLARE FUNCTION CPUInfo% (model%, submodel%, BiosRev%, cpu%, ndp%)
DECLARE FUNCTION DayOfYr%
DECLARE FUNCTION FUniq% (fil$, attr%, handle%)
DECLARE FUNCTION FClose% (handle%)
DECLARE FUNCTION FCount% (mask$)
DECLARE FUNCTION FReadArray% (SEG arry%, fhandle%, bytes%)
DECLARE FUNCTION FExists% (fil$)
DECLARE FUNCTION GetDrv% ()
DECLARE FUNCTION KeyReady%
DECLARE FUNCTION LCount% (buffer$, fhandle%)
DECLARE FUNCTION MenuCtrl% ()
DECLARE FUNCTION MHz%
DECLARE FUNCTION PtrStat% (x%)
DECLARE FUNCTION SysTicks&
DECLARE FUNCTION VidType% ()

DECLARE SUB SaveScrn (SEG arry%)
DECLARE SUB RestScrn (SEG arry%)
DECLARE SUB DirF (mask$, SEG FilArryPtr AS ANY)
DECLARE SUB PrintStatL (SEG MsgArray AS ANY, action%, attr%)

CLEAR
DEFINT A-Z
OPTION BASE 1

    CLS
    Crt = VidType                  ' get type of display

    IF (Crt MOD 2 = 0) OR (Crt = 2) THEN    ' set colors based on CRT Type
        fg = 7                     ' EGA mono, Mono, or VGA mono
        fgh = 15                   ' use bland colors
        fgw = 0
        bgw = 7
        NAttr = 112
        Rattr = 7
        cmode = 0
        wattr2 = AttrMake(7, 0)             ' set up some attributes
        wattr3 = AttrMake(0, 7)
        wattr4 = AttrMake(7, 0)
        wattr5 = AttrMake(0, 15)
        wattr6 = AttrMake(15, 0)

    ELSE
        fg = 3                     ' CGA, EGA or VGA
        fgh = 14                   ' use less bland colors
        fgw = 14
        bgw = 4
        NAttr = 78
        Rattr = 14
        cmode = 1
        wattr2 = AttrMake(7, 1)             ' set up some attributes
        wattr3 = AttrMake(1, 7)
        wattr4 = AttrMake(0, 11)
        wattr5 = AttrMake(3, 0)
        wattr6 = AttrMake(5, 14)
    END IF

    COLOR fg, 0

    TYPE struct                         ' type structure for DirF
        s AS STRING * 12
    END TYPE

    TYPE structa
        ls AS STRING * 80
    END TYPE

    REDIM menu$(28)                     ' string array of demo choices
    REDIM Mark(28)                      ' allow marking of up to 5

    REDIM msg$(4)
    msg$(1) = "Press any key to continue"
    msg$(2) = "GLIB: The standard in QB Libraries"
    msg$(3) = "This is a demo of TimeSquare"
    msg$(2) = "GLIB: So much Power, so few $$$"

    'set up status line messages
    REDIM SLine(2) AS structa
    SLine(1).ls = "               Navigate with Cursor keys.   Select with [Enter]  "
    SLine(2).ls = "    Mark up to 5 selections with [TAB] or [SpaceBar].    [Esc] Quits Demo"



    REDIM ScrText((7 * 2000) + 1)       ' up to 5 info screens

    REDIM ScrnArry(12001)               ' enough for 6 screens

    REDIM temp(10)                      ' for printing GLIB returns in a loop

    REDIM Arg$(10)                      ' storage for parsed command line
    NumArgs = 0
    CALL cmdline(Arg$(), NumArgs)       ' get command line arguments

    IF (NumArgs = 0) OR (FExists(Arg$(1)) = 0) THEN
        ScrFil$ = "ScrLib.DAT"
        IF FExists(ScrFil$) = 0 THEN
            GOSUB HowToRunDemo
            SYSTEM
        END IF
    ELSE
        ScrFil$ = Arg$(1)
        ScrNum = 0                      ' screen to load
    END IF

    ' the demo selections
    DATA Other InfoSoft Items, Boxes, Chirp, CmdLine, Date / DFRMAT, DIR
    DATA DrvSpace, DayOfYr, ErrorMessage, FExists, FlexMenu, FUniq, GetCH
    DATA LCount, MenuCtrl, ProperCase, Printer Routines (4), Painter
    DATA QPrint, SysInfo Routines, Scroll/Scroller, TFrmat/Systime
    DATA Save/Rest Scrn, Windows, VidON / VidOFF, Read / Write Array
    DATA Read / Write String, QUIT Demo (or [Esc])

    FOR x = 1 TO 28                     ' build the main menu
        READ menu$(x)
    NEXT x

    FOR x = 1 TO 3
        ScrNum = x                      ' set screen to load
        ScrPOS = ((x - 1) * 2000) + 1   ' array position to load to
        GOSUB LoadScrn
    NEXT x

    FOR x = 1 TO 3
        ScrOffs = ((x - 1) * 2000) + 1  ' set offset pointer to array
        CALL RestScrn(ScrText(ScrOffs)) ' display screen
        x$ = INPUT$(1)                  ' eat key press
    NEXT x

    title$ = " GLIB Demo "              ' FlexMenu title
    First = LBOUND(menu$)               ' first possible selection
    Last = UBOUND(menu$)                ' last (in case somebody messes with it)


    DO
        CLS
        MarkedItem = 0                  ' reset flags
        ArrayPOS = 0
        XtdChc = 5                      ' how many marks to allow
        REDIM Mark(Last)                ' erase old marks

        CALL PrintStatL(SLine(1), 0, 112)

        item = MenuChoice%(menu$(), -1, -1, NAttr%, Rattr%, title$, Mark%(), XtdChc%)

        IF XtdChc <> 27 THEN
            FOR i = First TO Last       ' check for marked items
                IF Mark(i) THEN

                    item = i
                    MarkedItem = 1
                    IF (item < Last + 1) THEN
                        GOSUB ExecItem
                    END IF

                END IF
            NEXT i

            IF MarkedItem = 0 THEN
                GOSUB ExecItem
            END IF
        END IF

    LOOP UNTIL (XtdChc = 27) OR (item = Last + 1)

    ' closing sequence
    CLS

    ScrNum = 1                     ' set screen to load
    ScrPOS = 1
    GOSUB LoadScrn
    CALL RestScrn(ScrText(1))

    msg$(1) = " Place your GLIB order now!  "          ' change final msgs
    msg$(3) = " Place your GLIB order now!  "
    LOCATE 24, 3
    PRINT SPACE$(60);

    CALL TimeSquare(msg$(), 24, 23, NAttr, 0)

    LOCATE 24, 3
    PRINT SPACE$(60);
    LOCATE 23, 1

SYSTEM

ExecItem:
    IF item > 20 THEN item = item + 1

    CLS

    DoFade = 0

    ScrNum = item + 3                   ' adjust for logo etc
    ScrPOS = 1                          ' adjust for OTHER INFO
    GOSUB LoadScrn

    'IF item <> 23 THEN
    CALL RestScrn(ScrText(ScrPOS))
    'END IF

    SELECT CASE item
        CASE 0, 1, 11

        CASE 2
            x$ = INPUT$(1)
            GOSUB BoxDemo

        CASE 3
            GOSUB ChirpDemo

        CASE 4
            GOSUB CmdLDemo

        CASE 5
            GOSUB DateStuff

        CASE 6
            x$ = INPUT$(1)
            GOSUB DirDemo

        CASE 7
            GOSUB DrvSpaceDemo

        CASE 8
            GOSUB DayYrDemo

        CASE 9
            GOSUB ErrMsgDemo

        CASE 10
            GOSUB ExistDemo

        CASE 12
            GOSUB UniqDemo

        CASE 13
            GOSUB GetChDemo

        CASE 14
            GOSUB LcountDemo

        CASE 15
            GOSUB MenuCtrlDemo

        CASE 16
            GOSUB PCaseDemo

        CASE 17
            GOSUB PtrDemo

        CASE 18
            x$ = INPUT$(1)
            GOSUB PaintDemo

        CASE 19
            x$ = INPUT$(1)
            GOSUB QPrintDemo

        CASE 20
            speed = MHz / 100       ' do test while reading screen
            x$ = INPUT$(1)
            ScrNum = ScrNum + 1     ' adjust for logo etc
            ScrPOS = 2              ' adjust for OTHER INFO
            GOSUB LoadScrn

            CALL RestScrn(ScrText(ScrPOS))

            GOSUB SysInfoDemo


        CASE 22
            x$ = INPUT$(1)
            GOSUB ScrlDemo

        CASE 23
            GOSUB TimeDemo

        CASE 24
            x$ = INPUT$(1)
            ScrNum = ScrNum + 1          ' adjust for logo etc
            ScrPOS = 2                   ' adjust for OTHER INFO
            GOSUB LoadScrn

            CALL RestScrn(ScrText(ScrPOS))
            x$ = INPUT$(1)
            GOSUB SrWdwsDemo


        CASE 25
            x$ = INPUT$(1)
            GOSUB SrWdwsDemo


        CASE 26
            x$ = INPUT$(1)
            GOSUB VidDemo

        CASE 27, 28

        CASE ELSE

    END SELECT


    GOSUB ContPrompt
    COLOR fg, 0

RETURN



'************* demo code ****************
BoxDemo:
    CLS
    CALL Boxes(1, 1, 6, 25, 1, 7)
    CALL MilliDelay(500)                ' pause long enough to appreciate
    CALL Boxes(10, 1, 20, 45, 2, 78)
    CALL MilliDelay(500)                ' otherwise all 7 pop up too fast
    CALL Boxes(1, 41, 16, 80, 3, 3)
    CALL MilliDelay(500)
    CALL Boxes(16, 31, 25, 75, 7, 14)
    CALL MilliDelay(500)
    CALL Boxes(5, 15, 23, 35, 6, 3)
    CALL MilliDelay(500)
    CALL Boxes(5, 55, 13, 79, 5, 2)
    CALL Delay18(2)
    CALL Boxes(15, 5, 18, 65, 4, 2)
    COLOR fgh, 0
    LOCATE 17, 7
    PRINT "Boxes can be placed anywhere and support 9 frame styles"
    DoFade = 1
RETURN


ChirpDemo:
    FOR x = 1 TO 5
        LOCATE 13 + x, 5
        IF x MOD 2 THEN
            CALL Chirp(0)
            PRINT "Ascending"
        ELSE
            CALL Chirp(1)
            PRINT "Descending"
        END IF
        CALL Delay18(12)                ' about 3/4 sec
    NEXT x
RETURN


CmdLDemo:
    x$ = INPUT$(1)                      ' eat a key
                    ' clear lower portion of screen
    CALL Windows(9, 2, 20, 79, 0, 1, 0, 0, "")

    FOR x = 1 TO NumArgs
        LOCATE 11 + x, 10
        PRINT "Argument number "; x; ": "; Arg$(x)
    NEXT x

RETURN


DateStuff:
    CALL date(mo, day, yr, dow)         ' get date variables
    CALL dfrmat(mo, day, yr, nudat$)    ' format to string
    COLOR fgh, 0
    LOCATE 14, 28
    PRINT DATE$
    LOCATE 15, 33
    PRINT nudat$
    LOCATE 19, 55
    PRINT mo; day; yr; dow              ' show DATE return
RETURN

DirDemo:
    mask$ = "*.bas"                     ' look for these files
    cnt = FCount(mask$)

    IF cnt < 3 THEN
        mask$ = "*.*"                   ' not enough files to be impressive
        cnt = FCount(mask$)             ' try *.*
    END IF

    REDIM FileList(cnt) AS struct       ' set up filelist as an array of
                                        ' cnt size of TYPE struct which
                                        ' contains only a Fixed Len Str
                                        ' of 12 chars long.
                                        ' - re structure 'STRUCT' as a string
                                        ' 11 or 13 chars long and see what
                                        ' happens.  The result is from the
                                        ' unique way QB structures Fixed Length
                                        ' Strings.

    CALL DirF(mask$, FileList(1))       ' fill the array with the found files
    CLS                                 ' print them.

    COLOR fgh, 0
    LOCATE 2, 25
    PRINT cnt;
    COLOR fg, bg
    PRINT " Files Found in mask "; : COLOR fgh, 0: PRINT mask$
    IF cnt > 51 THEN
        COLOR 7, 0
        PRINT TAB(20); "(Only the first 51 will be displayed.)"
        cnt = 51
    END IF

    y = 1
    z = 1
    col = 10
    COLOR fg, 0

    rowcnt = (cnt \ 3)                       ' even number rows in display


    FOR x = 1 TO rowcnt                 ' print them in reasonably orderly
                                        ' fashion
        FOR y = 1 TO 3
            LOCATE 5 + x, 10 + ((y - 1) * 25)
            PRINT z; FileList(z).s
            z = z + 1
        NEXT y

    NEXT x

    y = 1
    LOCATE 5 + x, 10 + ((y - 1) * 25)


    FOR q = z TO cnt
        PRINT q; FileList(q).s; TAB(10 + (y * 25));
    NEXT q

RETURN


DrvSpaceDemo:
    a = 0                               ' poll default drive
    CALL drvspace(a, b, c, d)
                                        ' interpet returns
    TotSpace& = CLNG(a%) * CLNG(c%) * CLNG(d%)
    FreeSpc& = CLNG(a%) * CLNG(c%) * CLNG(b%)

    COLOR fg                            ' display what we know
    LOCATE 12, 28
    PRINT TotSpace&; "bytes"
    LOCATE 14, 28
    PRINT FreeSpc&; "bytes"
RETURN


DayYrDemo:
    LOCATE 10, 42
    COLOR fgh, 0
    PRINT DayOfYr                        ' no need to assign it
RETURN


ErrMsgDemo:
    LOCATE 15, 10
    LINE INPUT "", msg$
    IF LEN(msg$) < 2 THEN
        msg$ = " You entered no message "
    END IF
    CALL ErrorMessage(msg$, 16, NAttr, 1)
    LOCATE 18, 20
    PRINT "ErrorMessage can also be quiet:"
    CALL MilliDelay(150)
    CALL ErrorMessage(msg$, 19, NAttr, 0)
    CALL Delay18(12)
RETURN


ExistDemo:
    LOCATE 15, 10
    fil$ = "GLIBDEMO.BAS"
    PRINT fil$;
    IF FExists(fil$) THEN               ' test it
        PRINT " exists!"                ' print findings
    ELSE
        PRINT " is missing."
    END IF

    LOCATE 16, 10
    fil$ = "FOOBAR.EXE"
    PRINT fil$;
    IF FExists(fil$) THEN
        PRINT " exists!"
    ELSE
        PRINT " is missing."
    END IF
RETURN


UniqDemo:
    fil$ = "\" + SPACE$(63)             ' storage for return
    errc = FUniq(fil$, 0, uh)           ' 0 = normal attribute
    errc = FClose(uh)                   ' close the file
    LOCATE 20, 15

    PRINT "Were I to need a scratch file, I could use ";
    COLOR fgh, 0
    fil$ = LTRIM$(RTRIM$(fil$))
    PRINT fil$                          ' print significant part of temp file
    KILL fil$
RETURN


GetChDemo:
    ky$ = " "
    LOCATE 24, 20
    PRINT "Understand the idea here (Y/N)?        ";
    CALL getch("YN", ky$)               ' only Y or N will be acted upon
    LOCATE 24, 10
    PRINT SPACE$(40);                   ' erase prompt
RETURN


LcountDemo:
    fil$ = "GLIB16.DOC"                 ' target file
    LOCATE 21, 5
    PRINT fil$;

    IF FExists(fil$) THEN               ' can we access it?
        ff = FREEFILE
        OPEN fil$ FOR INPUT AS #ff      ' open it
        ffh = FILEATTR(ff, 2)           ' convert to handle
        t! = TIMER                      ' start timer

        ' check out the self destructing buffer used here
        NumLines = LCount(SPACE$(4096), ffh)

        ' a second pass on this will show a LOT faster time
        PRINT " has"; NumLines; "lines and I took "; TIMER - t!; " secs to count them!"
        CLOSE #ff                       ' close the file
    ELSE
        PRINT " does not exist!"
    END IF

    fil$ = "GLIBDEMO.BAS"
    LOCATE 22, 5
    PRINT fil$;

    IF FExists(fil$) THEN
        ff = FREEFILE
        OPEN fil$ FOR INPUT AS #ff
        ffh = FILEATTR(ff, 2)
        t! = TIMER

        NumLines = LCount(SPACE$(4096), ffh)
        PRINT " has"; NumLines; "lines and I took "; TIMER - t!; " to count them!"
        CLOSE #ff
    ELSE
        PRINT " does not exist!"
    END IF


RETURN


MenuCtrlDemo:
    DO
        LOCATE 20, 15
        code = MenuCtrl                 ' get a F or nunber key
        IF code <> 15 THEN
            PRINT USING "You pressed [F-##] or the number ##"; code; code
        END IF
    LOOP UNTIL code = 15                ' escape quits
RETURN


PCaseDemo:
    LOCATE 14, 5
    LINE INPUT "", msg$                 ' get string
    msg$ = LCASE$(msg$)                 ' convert to LCASE for PCase
    CALL pcase(msg$)                    ' Make It Proper Case
    PRINT "PCase returns: ";
    COLOR fgh, 0
    PRINT msg$                          ' print return
RETURN


PaintDemo:
    CLS
    FOR x = 1 TO 405                    ' print a test pattern
        PRINT x;
    NEXT

    CALL SaveScrn(ScrnArry(1))          ' save the test pattern
    CALL RestScrn(ScrnArry(1))          ' restore it

    FOR x = 1 TO 35 STEP 5              ' the rainbow
        CALL Painter(1, 1, 12, 40, x)
        IF Crt <> 2 THEN                ' if CGA crt type then
            CALL Delay18(3)             '  slow down demo for
        END IF                          '  appreciation

        CALL Painter(12, 1, 25, 40, x + 1)
        IF Crt <> 2 THEN
            CALL Delay18(3)
        END IF


        CALL Painter(1, 41, 12, 80, x + 2)
        IF Crt <> 2 THEN
            CALL Delay18(3)
        END IF

        CALL Painter(12, 41, 25, 80, x + 3)
        IF Crt <> 2 THEN
            CALL Delay18(3)
        END IF

        CALL RestScrn(ScrnArry(1))      ' restore screen
    NEXT x

    CALL RestScrn(ScrText(ScrPOS))      ' restore Syntax screen
    CALL Painter(8, 1, 25, 80, 0)       ' make top part COLOR 0,0

    LOCATE 7, 5
    PRINT "Painter can also be used to hide text as we have on this screen."
    PRINT TAB(5); "Press any key to unhide it..."

    DO
    LOOP UNTIL KeyReady

    CALL Painter(9, 1, 25, 80, 7)       ' convert to COLOR 7,0
    DoFade = 1

RETURN

PtrDemo:
    ky$ = " "
    COLOR fgh, 0
    LOCATE 18, 5
    PRINT "Perform PrtScrn demo (Y/N)?"
    CALL getch("YN", ky$)
    IF ky$ = "Y" THEN
        CALL prtscrn                    ' darn simple
    END IF

    LOCATE 20, 5
    PRINT "Initialize LPT1: ";
    CALL PtrInit(1)                     ' legal printers are 1 to 4

    LOCATE 21, 5
    COLOR fg, 0
    PRINT "Checking status (wait a sec first): "
    CALL Delay(2)                       ' wait for low tech item
    stat = PtrStat(1)                   ' get status for prtr one
    LOCATE 22, 5
    PRINT "Printer is ";
    COLOR fgh, 0

    IF stat THEN
        PRINT "ready!"
    ELSE
        PRINT "not responding!"
    END IF
RETURN

QPrintDemo:
    CLS
    pstart! = TIMER                     ' start QB QPRINT timer

    FOR z = 1 TO 10
        FOR x = 1 TO 24                 ' fill screen with PRINT
            PRINT STRING$(80, CHR$(47 + z))
        NEXT x
    NEXT z
    pend! = TIMER                       ' halt timer

    CLS : BEEP                          ' let 'em know QPrint is on the way

    qstart! = TIMER                     ' start QPRINT timer
    FOR z = 1 TO 10                     ' fill screen 10 times
        FOR x = 1 TO 24
            CALL QPrint(STRING$(80, CHR$(47 + z)), x, 1, fg%)
        NEXT x
    NEXT z
    qend! = TIMER                       ' halt QPrint timer

    pelaps! = pend! - pstart!           ' calculate elapsed times
    qelaps! = qend! - qstart!

    CLS : LOCATE 10, 1                  ' show results
    PRINT "Elapsed time for PRINT "; pelaps!
    PRINT "Elapsed time for QPRINT "; qelaps!

RETURN


SysInfoDemo:
    FOR x = 1 TO 5                      ' initialze vars to 0
       temp(x) = 0
    NEXT x
    CALL SysInfo(temp(1), temp(2), temp(3), temp(4), temp(5))
    '             ram,     par,      ser     ega Mem  Vga flag

    COLOR fgh, 0
    FOR x = 1 TO 3                      ' calling with array variables
        LOCATE 5 + x, 20                ' makes printing easier
        PRINT USING "###"; temp(x)
    NEXT x

    LOCATE 9, 20
    PRINT USING "### Kb"; temp(4);      ' Ega KB

    LOCATE 10, 20                       ' VGA flag
    IF temp(4) THEN
        PRINT "Yes"
    ELSE
        PRINT " NO"
    END IF

    drv$ = CHR$(GetDrv) + ":"           ' get drive
    CALL GetVerify(vflag)               ' get V Flag

    LOCATE 6, 68
    PRINT drv$

    LOCATE 7, 68
    IF vflag THEN
        PRINT " ON"
    ELSE
        PRINT "OFF"
    END IF

    FOR x = 1 TO 5                      ' clear out any old returns
        temp(x) = 0
    NEXT x

    CALL VidInfo(temp(1), temp(2), temp(3), temp(4), temp(5))
    '             rows,    cols,    mode,    page,   page size

    LOCATE 14, 65
    SELECT CASE Crt                     ' crt determined at prog start
        CASE 0
            PRINT "MONO"
        CASE 1
            PRINT "HERC/HGC+"
        CASE 1
            PRINT "HERC InColor"
        CASE 3
            PRINT "CGA"
        CASE 4
            PRINT "EGA Mono"
        CASE 5
            PRINT "EGA Color"
        CASE 6
            PRINT "VGA Mono"
        CASE 7
            PRINT "VGA Color"
        CASE ELSE
            PRINT "unknown!"
    END SELECT

    FOR x = 1 TO 5
        LOCATE 14 + x, 65
        PRINT USING "####"; temp(x)
        temp(x) = 0                     ' clear for next call while printing
    NEXT x

    errc = CPUInfo(temp(1), temp(2), temp(3), temp(4), temp(5))
    '               Model,  Sub Mod, BiosRev,   cpu,    ndp


    FOR x = 1 TO 3
        LOCATE 13 + x, 20
        IF (errc <> 0) AND (x > 1) THEN  ' if ERRC is set, SubMdl and BRev
            PRINT "n/a"                  ' not supported
        ELSE
            PRINT USING "####"; temp(x)  ' Model is ok even if Errc
        END IF
    NEXT x

    LOCATE 19, 20
    IF temp(4) < 80 THEN                ' print CPU type
        PRINT USING " NEC V-##"; temp(4)
    ELSE
        PRINT USING " INTEL 80###"; temp(4)
    END IF

    LOCATE 18, 20                       ' print Math coprocessor type
    IF temp(5) THEN
        PRINT USING " 80###"; temp(5)
    ELSE
        PRINT " none"
    END IF

    LOCATE 21, 20                       ' speed was calculated while waiting
                                        ' for keypress - see main loop
    PRINT USING " ##.# MHz"; speed
RETURN


ScrlDemo:
    COLOR fg, 0                        ' QPRINT a test pattern
    FOR x = 1 TO 24
        CALL QPrint(STRING$(80, CHR$(x + 96)), x, 1, 2)
    NEXT x


    BEEP
    CALL SaveScrn(ScrnArry(1))          ' save the test pattern
    COLOR fgh, 0

    FOR x = 1 TO 15                           ' print the text at the
        CALL ScrollU(5, 20, 19, 59, fg, 1)    '  same line, let SCROLL
        LOCATE 19, 22                         '  move the text up the screen
        PRINT "Scroll Up Line # "; x;
    NEXT x

    COLOR fgh, 0
    LOCATE 15, 44: PRINT "Slow now, w/"
    LOCATE 16, 44: PRINT "frame (from Boxes)!"

    GOSUB ContPrompt                    ' wait for you to catch up

    CALL RestScrn(ScrnArry(1))          ' restore test pattern

    CALL Boxes(5, 28, 17, 52, 6, fgh)

    COLOR fg, 0
    FOR x = 1 TO 15        ' loop for 15 lines
        CALL ScrollD(6, 30, 16, 50, fhg, 1)     '   scroll down a line
        LOCATE 6, 31                            '   at top of window,....

        IF cmode THEN
            COLOR x, 0
        ELSE
            COLOR 15, 0
        END IF
        PRINT "Scroll Dn Line #"; x;              '   print the message
        CALL MilliDelay(500)                      '   waitasec
    NEXT x

    BEEP

    CLS
    LOCATE 10, 22
    PRINT "Now, shifting the screen using SCROLLER."

    GOSUB ContPrompt

    CALL RestScrn(ScrnArry(1))          ' restore test pattern
    BEEP

    FOR x = 1 TO 6
         CALL scroller(40)              ' scroll L/R with delay
         CALL MilliDelay(500)
         CALL scroller(-40)
         CALL MilliDelay(500)
    NEXT x
    CALL Delay(1)

    CALL RestScrn(ScrnArry(1))          ' restore test pattern

    BEEP
    FOR x = 1 TO 80                     ' more
        CALL scroller(-1)
    NEXT x
    SOUND 1200, .75
    LOCATE 15, 25
    PRINT "Scrolled lines are lost."

    CALL Delay(1)
    LOCATE 16, 30
    PRINT "Forever"
RETURN


TimeDemo:
     CALL TFrmat(atime$, 1)             ' format with
     CALL TFrmat(btime$, 0)             ' and without am/pm label
     CALL SysTime(h, m, s, hh)          ' get low level time

     COLOR fgh, 0
     LOCATE 15, 31
     PRINT TIME$                        ' print BASIC version
     LOCATE 16, 32
     PRINT btime$                       ' print ours
     LOCATE 16, 50
     PRINT atime$                       ' and ours

     LOCATE 19, 55
     PRINT h; m; s; hh                  ' and low level time
     LOCATE 22, 25
     PRINT SysTicks&
RETURN


SrWdwsDemo:
'<<<<
    CALL SaveScrn(ScrnArry(1))          ' now we have the screen with text
                                        ' captured in array

                                        ' window that Grows and Chirps
    CALL Windows(2, 2, 15, 55, 1, 1, 1, NAttr%, "Gro & SFX")

    IF Crt <> 2 THEN
        CALL MilliDelay(250)            ' pause a bit if NOT CGA
        LOCATE 8, 5
        COLOR fgw, bgw                  ' so wdws appear individually
        PRINT "There is a one quarter second delay"
        LOCATE , 5
        PRINT "between each window call for effect."
        LOCATE , 5
        PRINT "Untethered, they are even faster!"
    END IF

    CALL SaveScrn(ScrnArry(2001))       ' captured one with window one on it


                                        ' do a window, save the display, then
                                        ' pause for fast CRTs
    CALL Windows(12, 5, 23, 30, 0, 0, 2, wattr2%, "No Gro, No SFX")
    CALL SaveScrn(ScrnArry(4001))
    IF Crt <> 2 THEN
        CALL MilliDelay(250)
    END IF


    CALL Windows(2, 42, 13, 75, 0, 1, 3, wattr3%, "SFX Only")
    CALL SaveScrn(ScrnArry(6001))
    IF Crt <> 2 THEN
        CALL MilliDelay(250)
    END IF


    CALL Windows(5, 52, 23, 75, 1, 0, 0, wattr4%, "Gro Only")
    CALL SaveScrn(ScrnArry(8001))
    IF Crt <> 2 THEN
        CALL MilliDelay(250)
    END IF


    CALL Windows(15, 32, 24, 52, 1, 1, 2, wattr5%, "Gro & SFX")
    CALL SaveScrn(ScrnArry(10001))
    IF Crt <> 2 THEN
        CALL MilliDelay(250)
    END IF


    CALL Windows(2, 2, 6, 22, 0, 1, 3, wattr6%, "SFX Only")
    CALL SaveScrn(ScrnArry(12001))
    CALL MilliDelay(250)


    COLOR fgh, 1
    LOCATE 13, 6
    PRINT " With Save / RestScrn "
    LOCATE , 6
    PRINT "we can back up one "
    LOCATE , 6
    PRINT "layer at a time..."
    LOCATE , 6
    PRINT "I have added a .5 sec"
    LOCATE , 6
    PRINT "delay so you see what"
    LOCATE , 6
    PRINT "is going on."

    CALL ClrKBd                         ' eat up type ahead
    GOSUB ContPrompt


    CALL RestScrn(ScrnArry(10001))      ' pop back windows 1 at a time
    CALL MilliDelay(500)

    CALL RestScrn(ScrnArry(8001))
    CALL MilliDelay(500)

    CALL RestScrn(ScrnArry(6001))
    CALL MilliDelay(500)

    CALL RestScrn(ScrnArry(4001))
    CALL MilliDelay(500)

    CALL RestScrn(ScrnArry(2001))
    CALL MilliDelay(500)

    CALL RestScrn(ScrnArry(1))          ' original screen

    COLOR 15, 1
    CALL Windows(12, 5, 23, 30, 0, 0, 2, wattr2%, "Window 2")
    LOCATE 13, 6
    PRINT "We still have each level"
    LOCATE , 6
    PRINT "of screen in memory, and"
    LOCATE , 6
    PRINT "can recall any level we"
    LOCATE , 6
    PRINT "choose! "
    LOCATE , 6
    PRINT "Let's peel them back "
    LOCATE , 6
    PRINT "with sound."

    GOSUB ContPrompt

                                        ' compare this method with above
    FOR x = 10001 TO 1 STEP -2000
        CALL RestScrn(ScrnArry(x))
        CALL Chirp(0)
        CALL MilliDelay(500)
    NEXT x

RETURN


VidDemo:
   CALL vidoff
   ky$ = " "
   vdone = 0                              ' set loop indicator
   cy = 0

   DO UNTIL vdone
       CALL MilliDelay(1500)                ' delay 1.5 secs
       vky$ = INKEY$                        ' key waiting?
       IF vky$ > "" THEN                    '   yes we are done
           CALL vidon
           CALL pgetch(" Do it Again? ", 22, NAttr, "YN", ky$)
           LOCATE 22, 20
           PRINT SPACE$(50);
           IF ky$ = "N" THEN
               vdone = 1
           ELSE
               CALL vidoff
           END IF
       END IF

       IF cy MOD 2 = 0 THEN
           PLAY "L64O3AGE"              ' I'm bored
       ELSE
           SOUND 1200, .5               ' make some noise
       END IF
       cy = cy + 1

   LOOP
RETURN


MiscDemo:                               ' forgot what I was going to put here
RETURN


' **************** demo program support functions  **************
LoadScrn:
    ScrF = FREEFILE                     ' get BAS File No
    OPEN ScrFil$ FOR INPUT AS #ScrF
    scrFHandle = FILEATTR(ScrF, 2)      ' convert to handle

    bytes = 4000                        ' 4000 bytes per screen
    seekPos& = CLNG(CLNG(ScrNum - 1) * 4000) + 1
    SEEK #ScrF, seekPos&                ' use QB to seek to right spot
    errc = FReadArray(ScrText(ScrPOS), scrFHandle, bytes)
    CLOSE #ScrF                         ' no reason to keep file open
RETURN


HowToRunDemo:
    CLS
    LOCATE 5, 5
    PRINT "Cannot find 'SCRLIB.DAT'"
    PRINT TAB(5); "This demo depends on an external set of screens that holds"
    PRINT TAB(5); "the various screen displays.  Restart the demo from the"
    PRINT TAB(5); "batch file provided or using the command line listed in the demo source."
RETURN

ContPrompt:
    SOUND 1200, .5
    CALL ClrKBd
    CALL TimeSquare(msg$(), 24, 25, NAttr, 0)
    CALL ClrKBd                    ' some people get impatient
    IF DoFade THEN
        CALL Fade
    END IF
RETURN